home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / graphic / postogrf.zip / STRINGS.SRC < prev    next >
Text File  |  1989-06-06  |  7KB  |  185 lines
  1. { strings.src include file with various string handlers .
  2.   Written by Thomas B. Passin in TurboPascal 5.0}
  3. {   18 Oct 88 v1.0x3.  ReadRaw now only reverses screen attributes
  4.        if plot4 has been defined & InGraphMode is true.
  5.     28 Sept 88 v1.0x2
  6.     22 Sept 88 v1.0x1 }
  7.  
  8. { ------------------------ procedures ---------------------------
  9.    ReadRaw(var s:string80; prompt: string80;
  10.                       default:string80;);
  11.    Procedure StripWhite(var Line:string80);
  12.    Procedure LowerCase(var Comm:Namestr);
  13.    Procedure ParseComm(var Source, Destination:string80);
  14. }
  15.  
  16. (*{$DEFINE strtest}*)
  17.  
  18. {$IFDEF strtest}
  19. uses CRT;
  20. {$endif}
  21.  
  22. {$define STRINGS}
  23. type string80 = string[80];
  24. const CR = #13; ESC = #27; BS = #8; En = #79; SP = #32; TAB = #9;
  25.       Home = #71; LF = #10;
  26.       WhiteSpace:             set of char = [#8,#9,#10,#12,' '];
  27.       Yes : set of char = ['Y','y'];
  28. { ---------------------------------------------------------------
  29.     ReadRaw returns the following for the input string:
  30.       KEYSTROKE                              RETURNS
  31.     CR for 1st char                     s = default (erases string on screen)
  32.     CR any other time                   s = string typed on screen
  33.     SPACE for 1st char                  s = ''      (erases string on screen)
  34.     ESC anytime                         s = ESC     (erases string on screen)
  35.     <END>         moves to end of string, next input adds char to string
  36.  
  37.    default = default string.
  38.    Restores cursor to starting position on exit.
  39. }
  40. procedure ReadRaw(var s:string80; prompt: string80;
  41.                       default:string80);
  42. var chr: char; t1, t2, t3, start, ytemp:byte; tattrib:byte;
  43.     twherex, twherey:byte;
  44.          W1, W2:word;
  45.          done: boolean;
  46. begin s := default;  done := false;
  47.       twherex := wherex; twherey := wherey;
  48.       tattrib := textattr;
  49.       w1 := WindMin; w2 := Windmax;
  50.       ytemp := hi(w1) + wherey ;
  51.       start:= lo(w1) + 1;
  52.       t1 := start+ length(prompt) + 50;
  53.       if t1 > 79 then t1 := 79;
  54.       window(start,ytemp,t1, ytemp);
  55.       write(prompt);
  56.       start:= wherex; clrEOL;
  57.       if default <> '' then write(default);
  58.       t2 := wherex; t3 := start; GoToXY(start, whereY);
  59.       repeat chr := Readkey;
  60.                 case chr of
  61.                    BS:  if (s <> '') and (t3 <> start)
  62.                         then begin s := copy(s,1,length(s)-1);
  63.                                    dec(t3);
  64.                                    GoToXY(t3, wherey); clrEOL;
  65.                                    {write(' '); GoToXY(t3,wherey);}
  66.                              end
  67.                          else begin sound(2000); delay(25); nosound; end;
  68.                    ESC: begin s := ESC;
  69.                               GoToXY(start,wherey); clrEOL;
  70.                               done := true;
  71.                         end;
  72.                   #0: begin if keypressed then chr := Readkey;
  73.                             case chr of
  74.                                  En: begin t3 := start   + length(s) ;
  75.                                            GoToXY(t3, wherey);
  76.                                      end;
  77.                             end; {case}
  78.                             chr := #0;
  79.                       end;
  80.                   CR: begin if t3 = start then s := default;
  81.                             done := true;
  82.                       end;
  83.                 else begin if (t3 = start)
  84.                            then if chr = SP
  85.                                    then begin s := '';
  86.                                               clrEOL;
  87.                                               done := true;
  88.                                          end
  89.                                    else begin clrEOL; s := chr;
  90.                                               inc(t3); write(chr);
  91.                                             end
  92.                            else begin
  93.                                      inc(t3); write(chr);
  94.                                      s := s+chr;
  95.                                  end;
  96.                      end; {else}
  97.                 end; {case}
  98.         until done ;
  99.         textattr := tattrib;
  100.         clrEOL;
  101.         window(1+lo(w1), 1+hi(w1), 1 + lo(w2), 1+hi(w2));
  102.         GoToXY(twherex, twherey);
  103. end; {ReadRaw}
  104.  
  105.  
  106. { -----------------------------------------------------------------
  107.                             StripWhite
  108.   -----------------------------------------------------------------}
  109. Procedure StripWhite(var Line:string80);
  110.    { Removes leading whitespace in string.  Returns a null string ('')
  111.       if there is only whitespace in the string
  112.    }
  113. Var n:  integer;
  114. begin
  115.     if Line = '' then exit ELSE
  116.     begin
  117.       n := 1;
  118.       While (Line[n] in WhiteSpace) and (n < length(Line)) do n :=n+1;
  119.       if    Line[n] in WhiteSpace then Line := ''
  120.       ELSE  Line := Copy(Line,n, length(Line)-n+1);
  121.     end;
  122. end;
  123.  
  124. Procedure LowerCase(var Comm:string80);
  125. const Uppercase:set of char = ['A'..'Z'];
  126. var i:integer;
  127. begin
  128.      for i := 1 to Length(Comm) do
  129.          if Comm[i] in UpperCase
  130.          then Comm[i] := chr(Ord(Comm[i]) + ord('a')-ord('A'));
  131. end;
  132.  
  133.  
  134. { ----------------------------------------------------------------
  135. Command string parser. ParseComm strips leading whitespace from
  136. the source string, then puts the first word into the destination
  137. string.  The end of the word is detected by the first whitespace.
  138. Whitespace is defined as BS,LF,tab,FF, or a space.
  139. --------------------------------------------------------------------}
  140.  
  141. Procedure ParseComm(var Source, Destination:string80);
  142.    {
  143.  processes a string into separate words ("commands"):
  144.         Strips leading whitespace from Source string.
  145.         Removes first word- delineated by trailing whitespace-
  146.             from Source & copies it into Destination.
  147.         Destination word always starts with non-whitespace unless null.
  148.         Source is set to '' if it would have been a single space.
  149.         Sets Destination to '' if Source is a null string. }
  150. var n:                          integer;
  151. begin
  152.      if Source = '' then begin Destination := ''; exit; end  ELSE
  153.      begin
  154.        StripWhite(Source);
  155.        n := 1;
  156.        Repeat n :=n+1
  157.        Until (Source[n] {is} in WhiteSpace) or (n > length(Source));
  158.        Destination := copy(Source,1,n-1);
  159.        Source := copy(Source,n,length(source)-n+1);
  160.        if source = ' ' then source := '';
  161.      end;
  162. end;
  163.  
  164. {var   comm1, comm2:                string80;
  165. begin
  166.      readln(Comm2);
  167.      while Comm2 <> '' do
  168.      begin
  169.           ParseComm(Comm2,Comm1);
  170.           WRITE(COMM1,'*');
  171.           writeln(Comm2)
  172.      end
  173. end.}
  174.  
  175. {$ifdef strtest}
  176. var s:string80;
  177. begin
  178.      clrscr; textbackground(blue);
  179.      window(12,10,65,18); clrscr;
  180.      readraw(s,'key string: ', 'default');
  181.      writeln; textbackground(red); {clrscr;}
  182.      writeln(s);
  183. end
  184. {$endif}
  185.